home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / wow.em < prev   
Lisp/Scheme  |  1993-07-14  |  1KB  |  58 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: wow.em
  4. ;; Date: Mon Feb 10 15:49:32 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  Non working version of before, after, etc methods
  9.  
  10. (defmodule wow
  11.   (standard0
  12.    list-fns
  13.          
  14.  
  15.    )
  16.   ()
  17.   
  18.   (defclass gf-1 (generic-function) () metaclass generic-class)
  19.  
  20.   (defclass new-method (method) () metaclass method-class)
  21.   (defclass before-method (new-method) () metaclass method-class predicate beforep)
  22.   (defclass after-method (new-method) () metaclass method-class predicate afterp)
  23.   (defclass around-method (new-method) () metaclass method-class predicate aroundp)
  24.   
  25.   (defgeneric method-priority (meth)
  26.     methods ((((m method) 0))
  27.          (((m before-method)) 1)
  28.          (((m after-method)) -1)
  29.          (((m around-method)) 2)))
  30.   
  31.   (defmethod  compute-discriminating-function ((gf gf-1))
  32.     (lambda (sig)
  33.       (find-and-sort-applicable-methods gf sig)))
  34.  
  35.   (defun find-and-sort-applicable-methods (gf sig)
  36.     (flatten-alist (fold insert-method 
  37.               (find-applicable-methods gf sig)
  38.               nil)))
  39.             
  40.   (defun insert-method (meth lst)
  41.     (let ((val (method-priority meth)))
  42.       (cond ((null lst) (list (list val meth)))
  43.         ((< val (car lst))
  44.          (cons (list val meths)
  45.            lst))
  46.         ((= val (car lst))
  47.          (nconc (car lst) meth))
  48.         (t (cons (car lst)
  49.              (insert-method meth (cdr lst)))))))
  50.         
  51.   (defun flatten-alist (lst)
  52.     (fold (lambda (x l) (append (cdr x) l))
  53.       lst
  54.       nil))
  55.       
  56.   ;; end module
  57.   )
  58.